home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / perl5.005.tar.gz / perl5.005.tar / perl5.005 / t / op / regexp.t < prev    next >
Text File  |  1998-07-20  |  3KB  |  97 lines
  1. #!./perl
  2.  
  3. # XXX known to leak scalars
  4. $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3;
  5.  
  6. # The tests are in a separate file 't/op/re_tests'.
  7. # Each line in that file is a separate test.
  8. # There are five columns, separated by tabs.
  9. #
  10. # Column 1 contains the pattern, optionally enclosed in C<''>.
  11. # Modifiers can be put after the closing C<'>.
  12. #
  13. # Column 2 contains the string to be matched.
  14. #
  15. # Column 3 contains the expected result:
  16. #     y    expect a match
  17. #     n    expect no match
  18. #     c    expect an error
  19. #
  20. # Columns 4 and 5 are used only if column 3 contains C<y> or C<c>.
  21. #
  22. # Column 4 contains a string, usually C<$&>.
  23. #
  24. # Column 5 contains the expected result of double-quote
  25. # interpolating that string after the match, or start of error message.
  26. #
  27. # \n in the tests are interpolated.
  28. #
  29. # If you want to add a regular expression test that can't be expressed
  30. # in this format, don't add it here: put it in op/pat.t instead.
  31.  
  32. BEGIN {
  33.     chdir 't' if -d 't';
  34.     @INC = '../lib' if -d '../lib';
  35. }
  36.  
  37. use re 'eval';
  38.  
  39. $iters = shift || 1;        # Poor man performance suite, 10000 is OK.
  40.  
  41. open(TESTS,'op/re_tests') || open(TESTS,'t/op/re_tests') ||
  42.     die "Can't open re_tests";
  43.  
  44. while (<TESTS>) { }
  45. $numtests = $.;
  46. seek(TESTS,0,0);
  47. $. = 0;
  48.  
  49. $| = 1;
  50. print "1..$numtests\n# $iters iterations\n";
  51. TEST:
  52. while (<TESTS>) {
  53.     chomp;
  54.     s/\\n/\n/g;
  55.     ($pat, $subject, $result, $repl, $expect) = split(/\t/,$_);
  56.     $input = join(':',$pat,$subject,$result,$repl,$expect);
  57.     infty_subst(\$pat);
  58.     infty_subst(\$expect);
  59.     $pat = "'$pat'" unless $pat =~ /^[:']/;
  60.     $pat =~ s/\\n/\n/g;
  61.     $subject =~ s/\\n/\n/g;
  62.     $expect =~ s/\\n/\n/g;
  63.     $expect = $repl = '-' if $skip_amp and $input =~ /\$[&\`\']/;
  64.     for $study ("", "study \$subject") {
  65.      $c = $iters;
  66.      eval "$study; \$match = (\$subject =~ m$pat) while \$c--; \$got = \"$repl\";";
  67.     chomp( $err = $@ );
  68.     if ($result eq 'c') {
  69.         if ($err !~ m!^\Q$expect!) { print "not ok $. (compile) $input => `$err'\n"; next TEST }
  70.         last;  # no need to study a syntax error
  71.     }
  72.     elsif ($@) {
  73.         print "not ok $. $input => error `$err'\n"; next TEST;
  74.     }
  75.     elsif ($result eq 'n') {
  76.         if ($match) { print "not ok $. ($study) $input => false positive\n"; next TEST }
  77.     }
  78.     else {
  79.         if (!$match || $got ne $expect) {
  80.          print "not ok $. ($study) $input => `$got', match=$match\n";
  81.         next TEST;
  82.         }
  83.     }
  84.     }
  85.     print "ok $.\n";
  86. }
  87.  
  88. close(TESTS);
  89.  
  90. sub infty_subst                             # Special-case substitution
  91. {                                           #  of $reg_infty and friends
  92.     my $tp = shift;
  93.     $$tp =~ s/,\$reg_infty_m}/,$reg_infty_m}/o;
  94.     $$tp =~ s/,\$reg_infty_p}/,$reg_infty_p}/o;
  95.     $$tp =~ s/,\$reg_infty}/,$reg_infty}/o;
  96. }
  97.